home *** CD-ROM | disk | FTP | other *** search
- {$A+,D-,S10} {Compiler directives to make a desk accessory)
- { A+ only works with versions of Personal Pascal newer than 1.02
- D- turns off debug code
- S10 limits stack/heap space for this accessory to 10 kbytes}
-
- {******************************************************************************
-
- Some conventions used in this listing:
-
- Words in all capital letters (e.g. CHR) are Personal Pascal reserved words.
-
- Words with mixed capital and lower case letters (e.g. Text) are Personal
- Pascal constants, types, functions, or procedures as shown in the manual
- or in the included library (GEMCONST.PAS, GEMTYPE.PAS, GEMSUBS.PAS).
- There seems to be no significance to whether these words are one word
- (e.g. Text) or multiple words separated by an underline (e.g. Path_Name).
-
- Words in all lower case letters are mine:
- Variables are one word (e.g. path).
- Functions and procedures are two or more words separated with an underline
- (e.g. do_title).
-
- ******************************************************************************}
-
- PROGRAM personal_pascal_sourcecode_lister_accessory;
- {PPLISTER by Dave Rajala, 1987}
- {Portions are Copyright (c)1986 CCD and OSS. Used by permission of OSS.}
-
- {PPLISTER prints Personal Pascal source code files with line numbers added for
- reference. Epson compatable, elite-font-capable printer required. PPLISTER
- demonstrates GEM dialog boxes, alert boxes, windows, and messages as a desk
- accessory.}
-
-
- CONST
- {$I GEMCONST.PAS}
- AC_Open = 40;
- AC_Close = 41;
-
-
- TYPE
- {$I GEMTYPE.PAS}
-
-
- VAR {Global Variables}
- path : Path_Name; {String[80] to store path for file selector}
- userfile : Path_Name; {String[80] to store file name selected}
- disk : FILE OF Text; {File buffer required for disk I/O}
- printer : FILE OF Text; {File buffer required for printer output}
- x,y,w,h : Integer; {Upperleft screen coordinate and desktop size}
- cw,ch : Integer; {Character width and height}
- wx,wy,ww,wh : Integer; {Upperleft coordinate/size of progress window}
- ox,oy,ow,oh : Integer; {Old coordinate/size of progress window}
- wwc,whc : Integer; {Window width and height in character units}
- px,py : Integer; {Upperleft coordinate of progress message}
- pagestr : String; {Progress message for page number}
- linestr : String; {Progress message for line number}
- intstr : String; {String containing an integer for displaying}
- progwind : Integer; {Handle of progress window}
- wtitle : Window_Title; {String[80] for progress window title}
- winfo : String; {Progress window info line}
- msg : Message_Buffer; {Array[0..15] of Integer for event messages}
- key : Integer; {Value of last key pressed for event messages}
- linenum : Integer; {Line number for source code listing}
- pagenum : Integer; {Page number for source code listing}
- junk : Integer; {Collects useless data}
- junkb : Boolean; {Ditto}
- ap_id : integer; {ID of this desk accessory}
- ourname : String; {Name of our accessory for DESK menu}
- picked : Boolean; {Whether file selected}
- runbefore : Boolean; {Whether accessory has been called before}
-
- {$I GEMSUBS.PAS}
-
-
- FUNCTION do_title : Boolean; {Creates and displays title screen dialog box}
- {Returns true/false whether user clicks 'Print File'}
- VAR {Local}
- titlebox : Dialog_Ptr; {^Char variable for handle of dialog box}
- tline1 : Integer; {Handle of text line 1 for dialog box}
- tline2 : Integer; {Ditto for line 2}
- tline3 : Integer; {Ditto for line 3}
- tline4 : Integer; {Ditto for line 4}
- tline5 : Integer; {Ditto for line 5}
- tline6 : Integer; {Ditto for line 6}
- tline7 : Integer; {Ditto for line 7}
- quit : Integer; {Handle of QUIT button in dialog box}
- printfile : Integer; {Handle of PRINT FILE button in dialog box}
- pushed : Tree_Index; {Item which causes return from dialog box}
- textstring : String[40]; {Used to print non-keyboard characters}
- BEGIN
- titlebox := New_Dialog {New dialog box with handle 'titlebox'}
- (10, {Can contain a max of 10 items}
- 0,0, {Disregard upperleft coordinate of box}
- 40,12); {Box size is 40 characters by 12 lines}
- tline1 := Add_DItem {Add item to dialog box with handle 'tline1'}
- (titlebox, {Handle of box}
- G_Text, {Item is a non-editable text line}
- None, {No special flags}
- 1, {Start in first character position}
- 1, {of first line in box}
- 38,1, {This item 38 characters wide and 1 line high}
- 0, {No border around this item}
- (Black*256){Text color Black}
- |128); {Drawn in replace mode}
- {Add rest of lines}
- tline2 := Add_DItem (titlebox,G_Text,None,1,2,38,1,0,(Black*256)|128);
- tline3 := Add_DItem (titlebox,G_Text,None,1,3,38,1,0,(Black*256)|128);
- tline4 := Add_DItem (titlebox,G_Text,None,1,4,38,1,0,(Black*256)|128);
- tline5 := Add_DItem (titlebox,G_Text,None,1,5,38,1,0,(Black*256)|128);
- tline6 := Add_DItem (titlebox,G_Text,None,1,6,38,1,0,(Black*256)|128);
- tline7 := Add_DItem (titlebox,G_Text,None,1,7,38,1,0,(Black*256)|128);
- printfile := Add_DItem {Add item to dialog box with handle 'printfile'}
- (titlebox, {Handle of box}
- G_Button, {This item is a button}
- Selectable| {The button can be clicked}
- Touch_Exit| {Exit the dialog box when button clicked}
- Default, {Exit the dialog box when RETURN key pressed}
- 6, {Upperleft corner of button on 6th character}
- 9, {of 9th line of dialog box}
- 14,2, {Button 14 characters wide and 2 lines high}
- junk, {Border meaningless for button}
- junk); {Color meaningless for button}
- quit := Add_DItem {Add item to dialog box with handle 'quit'}
- (titlebox, {Handle of box}
- G_Button, {This item is a button}
- Selectable| {The button can be clicked}
- Touch_Exit, {Exit the dialog box when button clicked}
- 26, {Upperleft corner of button on 26th character}
- 9, {of 9th line of dialog box}
- 8,2, {Button 8 characters wide and 2 lines high}
- junk, {Border meaningless for button}
- junk); {Color meaningless for button}
- {Assign text to the dialog box items}
- Set_DText(titlebox, {Dialog box handle}
- tline1, {Item handle}
- 'Personal Pascal Source Code Lister', {Text}
- System_Font, {Use system font}
- TE_Center); {Center text}
- Set_DText(titlebox,tline2,'Author: Dave Rajala',System_Font,TE_Center);
- Set_DText(titlebox,tline3,'Rev 1.00',System_Font,TE_Center);
- Set_DText(titlebox,tline4,'This Program Placed in Public Domain.',
- System_Font,TE_Center);
- Set_DText(titlebox,tline5,' ',System_Font,TE_Center);
- textstring := CONCAT('Portions Copyright ',CHR(189),'1986 OSS/CCD.');
- Set_DText(titlebox,tline6,textstring,System_Font,TE_Center);
- Set_DText(titlebox,tline7,'Used by permission of OSS.',System_Font,
- TE_Center);
- Set_DText(titlebox,printfile,' PRINT FILE ',System_Font,TE_Center);
- Set_DText(titlebox,quit,' QUIT ',System_Font,TE_Center);
- Center_Dialog(titlebox); {Center dialog box on screen}
- pushed := Do_Dialog(titlebox,0); {Display box and wait for return}
- {Contrary to manual, 2d parameter of Do_Dialog is meaningful even if}
- {no editable text items in box. Must be 0 if no editable text items}
- End_Dialog(titlebox); {Remove box from screen}
- Delete_Dialog(titlebox); {Release memory back to GEM}
- do_title := (pushed = printfile); {TRUE if 'print file' clicked}
- END; {do_title}
-
-
- FUNCTION current_drive : Integer; {Returns current drive, 0=A, 1=B, etc}
- GEMDOS ($19);
-
-
- FUNCTION printer_stat : Integer; {Returns -1 if printer ready, 0 if not}
- GEMDOS ($11);
-
-
- FUNCTION printer_ok : Boolean; {Returns true/false whether printer ok}
- VAR {Local}
- status : Integer; {Printer status}
- errordata : String[255]; {Data for printer-not-ready alert box}
- BEGIN {printer_ok}
- status := printer_stat; {Get printer status}
- IF status = 0 THEN {If printer not ok}
- BEGIN {Do alert box}
- errordata := CONCAT ('[0]', {No sign}
- '[ ',CHR(28),CHR(29),' |', {Bob}
- ' ',CHR(30),CHR(31),' |', {Bob}
- ' Bob says |', {Text lines, 30 character max}
- 'THE PRINTER''S NOT READY! ]',
- '[Understood]'); {Button name}
- junk := Do_Alert (errordata,1); {Display box and wait for button}
- END; {If status=0}
- printer_ok := (status <> 0);
- END; {printer_ok}
-
-
- FUNCTION open_file (userfile : Path_Name): Boolean;
- {Tries to open file selected and returns true/false whether successful}
- VAR {Local}
- status : Integer; {I/O status of file}
- errordata : String[255]; {Stores data for I/O error alert box}
- badfile : String[30]; {Stores filename (possibly truncated)}
- BEGIN
- IO_CHECK (FALSE); {Turn off system error checking}
- RESET (disk, userfile); {Open selected file for input}
- status := IO_RESULT; {Get status}
- IO_CHECK (TRUE); {Turn system error checking back on}
- IF status <> 0 {If error opening disk file}
- THEN BEGIN
- IF LENGTH(userfile) > 30 {Limit file name to 30 char}
- THEN badfile := COPY(userfile,1,30) {or GEM will bomb}
- ELSE badfile := COPY(userfile,1,LENGTH(userfile));
- errordata := CONCAT ('[0]', {No sign}
- '[ ',CHR(28),CHR(29),' |', {Bob}
- ' ',CHR(30),CHR(31),' |', {Bob}
- ' Bob says |', {Text lines, 30 characters max}
- 'ERROR TRYING TO OPEN FILE: |',
- badfile,']',
- '[ OK ]'); {Button name}
- junk := Do_Alert (errordata,1); {Display box and wait for button}
- END; {If}
- open_file := (status = 0);
- END; {open_file}
-
-
- PROCEDURE int_to_str (number : Long_Integer; VAR intstr : String);
- {Receives integer and string, puts integer value into string. Assumes
- integer always positive.}
- BEGIN
- intstr := ' '; {Init string with 1 character}
- {so INSERT won't bomb on null string}
- WHILE number > 0 DO {While there's a significant digit}
- BEGIN
- INSERT(CHR((number MOD 10)+48), {Convert lowest digit to ascii char}
- intstr,1); {Insert it at beginning of string}
- number := number DIV 10; {Reduce number by 1 digit}
- END; {While}
- IF intstr = ' ' {If intstr is ' ', number was zero}
- THEN intstr := '0' {So show as '0' or}
- ELSE intstr := COPY(intstr,1,LENGTH(intstr)-1); {Strip trailing blank}
- END; {int_to_str}
-
-
- PROCEDURE create_progwind; {Creates GEM window to show printing progress}
- BEGIN
- wtitle := ' PRINTING ';
- progwind := New_Window {New window with handle 'progwind'}
- (G_Name {It will have a name}
- |G_Info {and an info line}
- |G_Move {It can be moved}
- |G_Close {and closed}
- |G_UpArrow {It'll have arrows just for looks}
- |G_DnArrow
- |G_LArrow
- |G_RArrow,
- wtitle, {Window title must be in a string variable}
- 0,0,0,0); {Window can be drawn as large as the desktop}
- END; {create_progwind}
-
-
- PROCEDURE display_progwind; {Display progress window on screen}
- VAR {Local}
- i : Integer; {FOR counter}
- BEGIN
- px := wx + cw*((wwc DIV 2) - 7); {Coordinates for progress prompt}
- py := wy + ch*(whc DIV 2); {See initialize for variable values}
- {Center userfile in winfo string}
- IF LENGTH(userfile) > wwc -1 {If file name wider than window}
- THEN
- winfo := COPY(userfile,1,wwc) {Truncate file name to window width}
- ELSE {If file name smaller than window}
- BEGIN
- winfo := COPY(userfile,1,LENGTH(userfile)); {Copy file name}
- FOR i := 1 to ((wwc DIV 2)-(LENGTH(userfile) DIV 2)) DO
- INSERT(' ',winfo,1); {Insert blanks to center file name}
- END; {Else}
- Set_WInfo(progwind,winfo); {Put file name in window info line}
- Hide_Mouse; {Prevent mouse cursor interferring}
- Paint_Color (White);
- Paint_Rect (wx,wy,ww,wh); {Paint window area before drawing window}
- Open_Window(progwind,wx,wy,ww,wh);{Draw window}
- Draw_String (px,py,pagestr); {Draw pagenum prompt in window}
- int_to_str(pagenum,intstr); {Convert page number to string}
- Draw_String (px+cw*LENGTH(pagestr),py,intstr); {Draw it in window}
- Draw_String (px,py+ch*2,linestr); {Draw linenum prompt in window}
- int_to_str(linenum,intstr); {Convert line number to string}
- Draw_String (px+cw*LENGTH(linestr),py+ch*2,intstr); {Draw it in window}
- Show_Mouse;
- END; {display_progwind}
-
-
- PROCEDURE update_linenum; {Displays linenum currently printing}
- BEGIN
- IF Front_Window = progwind THEN {If progress window is front window}
- BEGIN
- int_to_str(linenum,intstr); {Convert line number to string}
- Draw_String (px+cw*LENGTH(linestr),py+ch*2,intstr); {Draw it in window}
- END; {If}
- END; {update_linenum}
-
-
- PROCEDURE update_pagenum; {Displays pagenum currently printing}
- BEGIN
- IF Front_Window = progwind THEN {If progress window is front window}
- BEGIN
- int_to_str(pagenum,intstr); {Convert page number to string}
- Draw_String (px+cw*LENGTH(pagestr),py,intstr); {Draw it in window}
- END; {If}
- END; {update_pagenum}
-
-
- PROCEDURE do_redraw; {Redraws progress window based on GEM messages}
- VAR {Local}
- rx,ry,rw,rh : Integer; {Size of redraw rectangle}
- BEGIN
- Paint_Color(White);
- Begin_Update; {Prevent further screen changes while redrawing}
- Hide_Mouse;
- First_Rect(msg[3],rx,ry,rw,rh); {First redraw rectangle from GEM}
- WHILE (rw <> 0) AND (rh <> 0) DO {While there's a rectangle to redraw}
- BEGIN
- IF Rect_Intersect(msg[4],msg[5],msg[6],msg[7],rx,ry,rw,rh) THEN
- BEGIN {If redraw area intersects with progress window}
- Set_Clip(rx,ry,rw,rh); {Draw only in intersection rectangle}
- Paint_Rect (rx,ry,rw,rh); {Paint it white}
- Draw_String (px,py,pagestr); {Draw pagenum prompt}
- int_to_str(pagenum,intstr); {Convert page number to string}
- Draw_String (px+cw*LENGTH(pagestr),py,intstr); {Draw it}
- Draw_String (px,py+ch*2,linestr); {Draw linenum prompt}
- int_to_str(linenum,intstr); {Convert line number to string}
- Draw_String (px+cw*LENGTH(linestr),py+ch*2,intstr); {Draw it}
- END; {If}
- Next_Rect(msg[3],rx,ry,rw,rh); {Get any more redraw rectangles}
- END; {While}
- Show_Mouse;
- End_Update; {Allow other screen changes}
- END; {do_redraw}
-
-
- PROCEDURE do_move; {Moves progress window}
- BEGIN
- wx := msg[4]; {Accept new upperleft coordinates}
- wy := msg[5];
- Close_Window(progwind); {Erase current window}
- display_progwind; {Draw the new window}
- END; {do_move}
-
-
- PROCEDURE get_messages; {Returns any pending GEM messages in 'msg' and key}
- BEGIN
- {Since this returns immediately (timer=0)}
- msg[0] := 0; {Clear msg buffer to avoid repeating last message}
- junk := Get_Event (E_Message|E_Timer {Check messages,timer}
- |E_Keyboard, {and keys}
- 0,0,0, {Disregard mouse buttons}
- 0, {Return immediately (when timer=0)}
- FALSE,0,0,0,0, {Disregard mouse cursor location}
- FALSE,0,0,0,0, {ditto}
- msg,key, {Messages & keys are what we want}
- junk,junk,junk,junk,junk); {Disregard other stuff}
- END; {get_messages}
-
-
- FUNCTION check_messages : Boolean;
- {Does all GEM stuff for print_file and returns true if printing cancelled}
- VAR
- cancelled : Boolean;
- BEGIN
- cancelled := FALSE;
- get_messages; {From GEM}
- IF (msg[0] = WM_Redraw) AND (msg[3] = progwind)
- THEN do_redraw; {Redraw window if GEM says so}
- IF (msg[0] = WM_Moved) AND (msg[3] = progwind)
- THEN do_move; {Move window if GEM says so}
- IF (msg[0] = WM_Topped) AND (msg[3] = progwind)
- THEN Bring_To_Front(progwind); {Top window if GEM says so}
- IF ((msg[0] = WM_Closed) AND (msg[3] = progwind)) {If progwind closed}
- THEN cancelled := TRUE; {then cancelled}
- IF (key & 255 = 27) {If escape key pressed}
- THEN cancelled := TRUE; {then cancelled}
- check_messages := cancelled; {Return result}
- END; {check_messages}
-
-
- PROCEDURE show_cancel; {Informs user that printing was aborted}
- VAR {Local}
- errordata : String[255]; {Data for printing-aborted alert box}
- BEGIN {show_cancel}
- errordata := CONCAT ('[0]', {No sign}
- '[ ',CHR(28),CHR(29),' |', {Bob}
- ' ',CHR(30),CHR(31),' |', {Bob}
- ' Bob says |', {Text lines, 30 characters max}
- 'YOU ABORTED PRINTING BEFORE |',
- 'END OF FILE! ]',
- '[I Knew That]'); {Button name}
- junk := Do_Alert (errordata,1); {Display box and wait for button}
- END; {show_cancel}
-
-
- PROCEDURE print_bar; {Prints column spacing reference line}
- BEGIN {Numbers align with Personal Pascal tab settings}
- WRITE (printer,' 0---|---1---|---2---|---3---|---4---|---');
- WRITELN (printer, '5---|---6---|---7---|---8---|---9---|--');
- END; {print_bar}
-
-
- PROCEDURE print_file; {Lists selected disk file to printer}
- VAR {Local}
- i : Integer; {Multi-purpose counter}
- oneline : String [80]; {Stores one line of text}
- done : Boolean; {Stores true/false to exit procedure}
- pagefull : Boolean; {Stores true/false for page full}
- cancelled: Boolean; {Stores true/false for printing cancelled}
- select : Char; {Stores printer control code}
- font : Char; {ditto}
- elite : Char; {ditto}
- lmargin : Char; {ditto}
- five : Char; {ditto}
- defaults : Char; {ditto}
- formfeed : Char; {ditto}
- BEGIN {print_file}
- {Initialize variables}
- linenum := 1;
- pagenum := 1;
- cancelled := FALSE;
- select := CHR(27); {Epson Escape}
- font := CHR(33); {Epson Master font selector}
- elite := CHR(65); {Epson Elite font}
- lmargin := CHR(108); {Epson Left margin selector}
- five := CHR(5); {Epson margin setting}
- defaults := CHR(64); {Epson master reset code}
- formfeed := CHR(12); {Epson formfeed}
- pagestr := 'NOW ON PAGE: '; {Part of progress message}
- linestr := ' LINE: '; {Ditto}
- WRITE (printer, select, defaults); {Set printer}
- WRITE (printer, select, font, elite);
- WRITE (printer, select, lmargin, five);
- create_progwind; {Make window to show printing progress}
- display_progwind; {Display it}
- {Print the file}
- REPEAT
- {Center file name at top of every page}
- WRITELN (printer, userfile:43 + (LENGTH(userfile) DIV 2));
- WRITELN (printer); {Print blank line}
- print_bar; {Print column-spacing reference line at top of every page}
- pagefull := false;
- REPEAT
- done := EOF(disk); {Check for end of diskfile}
- IF NOT done
- THEN
- BEGIN
- READLN (disk, oneline); {Read one line from disk file}
- WRITELN (printer, linenum:4, ' ', oneline); {Print it}
- END {If then}
- ELSE {If done}
- WRITELN (printer); {Fill last page with blank lines}
- pagefull := (linenum MOD 53 = 0); {Print 53 lines per page}
- linenum := linenum+1;
- update_linenum; {Print current line number in progress window}
- cancelled := check_messages;
- UNTIL pagefull OR cancelled; {End Repeat}
- IF NOT cancelled
- THEN
- BEGIN
- print_bar; {Print column-spacing reference at bottom of all pages}
- WRITELN (printer); {Skip a line}
- WRITELN (printer, 'PAGE':43, pagenum:4); {Center pagenum}
- FOR i := 1 to 7 DO WRITELN (printer); {Move to top of next page}
- pagenum := pagenum+1;
- update_pagenum; {Draw new page number in progress window}
- END {If}
- ELSE {If cancelled}
- BEGIN
- WRITELN (printer);
- WRITELN (printer,'*** PRINTING ABORTED BEFORE END OF FILE ***');
- WRITE (printer,formfeed); {Move to top of next form}
- END; {Else}
- UNTIL done OR cancelled; {End repeat}
- WRITE (printer, select, defaults);
- CLOSE (disk);
- Close_Window(progwind); {Clean up screen}
- Delete_Window(progwind); {Release memory back to GEM}
- IF cancelled
- THEN show_cancel;
- END; {print_file}
-
-
- PROCEDURE initialize;
- BEGIN
- Work_Rect (0,x,y,w,h); {Find upperleft coordinate and size of desktop}
- Sys_Font_Size (cw,ch,junk,junk); {Find size of text}
- wwc := 30; {Start with window width of 30 characters}
- whc := 8; {and a height of 8 characters}
- ww := wwc * cw; {Make window 'wwc' characters wide}
- wh := whc * ch; {Make window 'whc' text lines high}
- wx := x+(w DIV 2)-(ww DIV 2); {Calculate coordinates to center window}
- wy := y+(h DIV 2)-(wh DIV 2);
- path := CONCAT {Set path for file selector to}
- (CHR(current_drive + 65), {current drive}
- ':\*.PAS'); {and '*.PAS' files}
- runbefore := TRUE;
- END; {initialize}
-
-
- PROCEDURE we_are_on; {Really main program of this accessory}
- VAR
- p,i : Integer;
- tempstr : String;
- BEGIN
- IF NOT(runbefore) {If first time accessory is run}
- THEN initialize; {then initialize}
- Set_Mouse(M_Arrow); {Ensure busy bee is off}
- REWRITE (printer, 'LST:'); {Set printer as LIST device}
- WHILE do_title DO {While user choice is 'print file'}
- BEGIN
- Begin_Update; {Prevent main program messing up file selector}
- picked := Get_In_File(path, userfile); {Display file selector}
- End_Update; {Allow screen changes again}
- IF picked THEN {If user selects file}
- BEGIN
- IF open_file(userfile) THEN {If file selected opens ok}
- IF printer_ok THEN {and if printer online}
- print_file; {print the file}
- p := POS('.',userfile); {Find extender in selected file name}
- IF p > 0 {Put extender or '*' in tempstr}
- THEN tempstr := COPY(userfile,p+1,LENGTH(userfile)-p)
- ELSE tempstr := '*';
- p := POS('.',path); {Find period in file selector path}
- IF p > 0 THEN {If path has an extender}
- path := COPY(path,1,p-1); {Strip extender from path}
- path := CONCAT(path,'.',tempstr); {Add new extender to path}
- END; {If picked}
- END; {While}
- END; {we_are_on}
-
-
- PROCEDURE Menu_Register( ap_id: integer; VAR name: String );
- EXTERNAL; {Registers our desk accessory with GEM}
-
-
- BEGIN {Main Program}
- ap_id := Init_Gem;
- IF ap_id >= 0 THEN {If GEM available}
- BEGIN {Give name for DESK menu}
- ourname := ' Pers Pascal Lister';
- Menu_Register(ap_id,ourname); {Register our accessory with GEM}
- WHILE TRUE DO {This is always true}
- BEGIN
- get_messages;
- IF msg[0] = AC_Open {If our accessory opened}
- THEN we_are_on; {then do our stuff}
- END; {While}
- Exit_Gem; {This will never execute}
- END; {If ap_id >= 0}
- END. {Main Program}
-